home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / CPANPLUS / Shell / Classic.pm next >
Encoding:
Perl POD Document  |  2009-06-26  |  32.9 KB  |  1,237 lines
  1. ##################################################
  2. ###            CPANPLUS/Shell/Classic.pm       ###
  3. ###    Backwards compatible shell for CPAN++   ###
  4. ###      Written 08-04-2002 by Jos Boumans     ###
  5. ##################################################
  6.  
  7. package CPANPLUS::Shell::Classic;
  8.  
  9. use strict;
  10.  
  11.  
  12. use CPANPLUS::Error;
  13. use CPANPLUS::Backend;
  14. use CPANPLUS::Configure::Setup;
  15. use CPANPLUS::Internals::Constants;
  16.  
  17. use Cwd;
  18. use IPC::Cmd;
  19. use Term::UI;
  20. use Data::Dumper;
  21. use Term::ReadLine;
  22.  
  23. use Module::Load                qw[load];
  24. use Params::Check               qw[check];
  25. use Module::Load::Conditional   qw[can_load];
  26.  
  27. $Params::Check::VERBOSE       = 1;
  28. $Params::Check::ALLOW_UNKNOWN = 1;
  29.  
  30. BEGIN {
  31.     use vars        qw[ $VERSION @ISA ];
  32.     @ISA        =   qw[ CPANPLUS::Shell::_Base::ReadLine ];
  33.     $VERSION    =   '0.0562';
  34. }
  35.  
  36. load CPANPLUS::Shell;
  37.  
  38.  
  39. ### our command set ###
  40. my $map = {
  41.     a           => '_author',
  42.     b           => '_bundle',
  43.     d           => '_distribution',
  44.     'm'         => '_module',
  45.     i           => '_find_all',
  46.     r           => '_uptodate',
  47.     u           => '_not_supported',
  48.     ls          => '_ls',
  49.     get         => '_fetch',
  50.     make        => '_install',
  51.     test        => '_install',
  52.     install     => '_install',
  53.     clean       => '_not_supported',
  54.     look        => '_shell',
  55.     readme      => '_readme',
  56.     h           => '_help',
  57.     '?'         => '_help',
  58.     o           => '_set_conf',
  59.     reload      => '_reload',
  60.     autobundle  => '_autobundle',
  61.     '!'         => '_bang',
  62.     #'q'         => '_quit', # done it the loop itself
  63. };
  64.  
  65. ### the shell object, scoped to the file ###
  66. my $Shell;
  67. my $Brand   = 'cpan';
  68. my $Prompt  = $Brand . '> ';
  69.  
  70. sub new {
  71.     my $class   = shift;
  72.  
  73.     my $cb      = new CPANPLUS::Backend;
  74.     my $self    = $class->SUPER::_init(
  75.                             brand   => $Brand,
  76.                             term    => Term::ReadLine->new( $Brand ),
  77.                             prompt  => $Prompt,
  78.                             backend => $cb,
  79.                             format  => "%5s %-50s %8s %-10s\n",
  80.                         );
  81.     ### make it available package wide ###
  82.     $Shell = $self;
  83.  
  84.     ### enable verbose, it's the cpan.pm way
  85.     $cb->configure_object->set_conf( verbose => 1 );
  86.  
  87.  
  88.     ### register install callback ###
  89.     $cb->_register_callback(
  90.             name    => 'install_prerequisite',
  91.             code    => \&__ask_about_install,
  92.     );
  93.  
  94.     ### register test report callback ###
  95.     $cb->_register_callback(
  96.             name    => 'edit_test_report',
  97.             code    => \&__ask_about_test_report,
  98.     );
  99.  
  100.     return $self;
  101. }
  102.  
  103. sub shell {
  104.     my $self = shift;
  105.     my $term = $self->term;
  106.  
  107.     $self->_show_banner;
  108.     $self->_input_loop && print "\n";
  109.     $self->_quit;
  110. }
  111.  
  112. sub _input_loop {
  113.     my $self    = shift;
  114.     my $term    = $self->term;
  115.     my $cb      = $self->backend;
  116.  
  117.     my $normal_quit = 0;
  118.     while (
  119.         defined (my $input = eval { $term->readline($self->prompt) } )
  120.         or $self->_signals->{INT}{count} == 1
  121.     ) {
  122.         ### re-initiate all signal handlers
  123.         while (my ($sig, $entry) = each %{$self->_signals} ) {
  124.             $SIG{$sig} = $entry->{handler} if exists($entry->{handler});
  125.         }
  126.  
  127.         last if $self->_dispatch_on_input( input => $input );
  128.  
  129.         ### flush the lib cache ###
  130.         $cb->_flush( list => [qw|lib load|] );
  131.  
  132.     } continue {
  133.         $self->_signals->{INT}{count}--
  134.             if $self->_signals->{INT}{count}; # clear the sigint count
  135.     }
  136.  
  137.     return 1;
  138. }
  139.  
  140. sub _dispatch_on_input {
  141.     my $self = shift;
  142.     my $conf = $self->backend->configure_object();
  143.     my $term = $self->term;
  144.     my %hash = @_;
  145.  
  146.     my $string;
  147.     my $tmpl = {
  148.         input   => { required => 1, store => \$string }
  149.     };
  150.  
  151.     check( $tmpl, \%hash ) or return;
  152.  
  153.     ### the original force setting;
  154.     my $force_store = $conf->get_conf( 'force' );
  155.  
  156.     ### parse the input: the first part before the space
  157.     ### is the command, followed by arguments.
  158.     ### see the usage below
  159.     my $key;
  160.     PARSE_INPUT: {
  161.         $string =~ s|^\s*([\w\?\!]+)\s*||;
  162.         chomp $string;
  163.         $key = lc($1);
  164.     }
  165.  
  166.     ### you prefixed the input with 'force'
  167.     ### that means we set the force flag, and
  168.     ### reparse the input...
  169.     ### YAY goto block :)
  170.     if( $key eq 'force' ) {
  171.         $conf->set_conf( force => 1 );
  172.         goto PARSE_INPUT;
  173.     }
  174.  
  175.     ### you want to quit
  176.     return 1 if $key =~ /^q/;
  177.  
  178.     my $method = $map->{$key};
  179.     unless( $self->can( $method ) ) {
  180.         print "Unknown command '$key'. Type ? for help.\n";
  181.         return;
  182.     }
  183.  
  184.     ### dispatch the method call
  185.     eval { $self->$method(
  186.                     command => $key,
  187.                     result  => [ split /\s+/, $string ],
  188.                     input   => $string );
  189.     };
  190.     warn $@ if $@;
  191.  
  192.     return;
  193. }
  194.  
  195. ### displays quit message
  196. sub _quit {
  197.  
  198.     ### well, that's what CPAN.pm says...
  199.     print "Lockfile removed\n";
  200. }
  201.  
  202. sub _not_supported {
  203.     my $self = shift;
  204.     my %hash = @_;
  205.  
  206.     my $cmd;
  207.     my $tmpl = {
  208.         command => { required => 1, store => \$cmd }
  209.     };
  210.  
  211.     check( $tmpl, \%hash ) or return;
  212.  
  213.     print "Sorry, the command '$cmd' is not supported\n";
  214.  
  215.     return;
  216. }
  217.  
  218. sub _fetch {
  219.     my $self = shift;
  220.     my $cb   = $self->backend;
  221.     my %hash = @_;
  222.  
  223.     my($aref, $input);
  224.     my $tmpl = {
  225.         result  => { store => \$aref, default => [] },
  226.         input   => { default => 'all', store => \$input },
  227.     };
  228.  
  229.     check( $tmpl, \%hash ) or return;
  230.  
  231.     for my $mod (@$aref) {
  232.         my $obj;
  233.  
  234.         unless( $obj = $cb->module_tree($mod) ) {
  235.             print "Warning: Cannot get $input, don't know what it is\n";
  236.             print "Try the command\n\n";
  237.             print "\ti /$mod/\n\n";
  238.             print "to find objects with matching identifiers.\n";
  239.  
  240.             next;
  241.         }
  242.  
  243.         $obj->fetch && $obj->extract;
  244.     }
  245.  
  246.     return $aref;
  247. }
  248.  
  249. sub _install {
  250.     my $self = shift;
  251.     my $cb   = $self->backend;
  252.     my %hash = @_;
  253.  
  254.     my $mapping = {
  255.         make        => { target => TARGET_CREATE, skiptest => 1 },
  256.         test        => { target => TARGET_CREATE },
  257.         install     => { target => TARGET_INSTALL },
  258.     };
  259.  
  260.     my($aref,$cmd);
  261.     my $tmpl = {
  262.         result  => { store => \$aref, default => [] },
  263.         command => { required => 1, store => \$cmd, allow => [keys %$mapping] },
  264.     };
  265.  
  266.     check( $tmpl, \%hash ) or return;
  267.  
  268.     for my $mod (@$aref) {
  269.         my $obj = $cb->module_tree( $mod );
  270.  
  271.         unless( $obj ) {
  272.             print "No such module '$mod'\n";
  273.             next;
  274.         }
  275.  
  276.         my $opts = $mapping->{$cmd};
  277.         $obj->install( %$opts );
  278.     }
  279.  
  280.     return $aref;
  281. }
  282.  
  283. sub _shell {
  284.     my $self    = shift;
  285.     my $cb      = $self->backend;
  286.     my $conf    = $cb->configure_object;
  287.     my %hash    = @_;
  288.  
  289.     my($aref, $cmd);
  290.     my $tmpl = {
  291.         result  => { store => \$aref, default => [] },
  292.         command => { required => 1, store => \$cmd },
  293.  
  294.     };
  295.  
  296.     check( $tmpl, \%hash ) or return;
  297.  
  298.  
  299.     my $shell = $conf->get_program('shell');
  300.     unless( $shell ) {
  301.         print "Your configuration does not define a value for subshells.\n".
  302.               qq[Please define it with "o conf shell <your shell>"\n];
  303.         return;
  304.     }
  305.  
  306.     my $cwd = Cwd::cwd();
  307.  
  308.     for my $mod (@$aref) {
  309.         print "Running $cmd for $mod\n";
  310.  
  311.         my $obj = $cb->module_tree( $mod )  or next;
  312.         $obj->fetch                         or next;
  313.         $obj->extract                       or next;
  314.  
  315.         $cb->_chdir( dir => $obj->status->extract )   or next;
  316.  
  317.         local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt;
  318.         if( system($shell) and $! ) {
  319.             print "Error executing your subshell '$shell': $!\n";
  320.             next;
  321.         }
  322.     }
  323.     $cb->_chdir( dir => $cwd );
  324.  
  325.     return $aref;
  326. }
  327.  
  328. sub _readme {
  329.     my $self    = shift;
  330.     my $cb      = $self->backend;
  331.     my $conf    = $cb->configure_object;
  332.     my %hash    = @_;
  333.  
  334.     my($aref, $cmd);
  335.     my $tmpl = {
  336.         result  => { store => \$aref, default => [] },
  337.         command => { required => 1, store => \$cmd },
  338.  
  339.     };
  340.  
  341.     check( $tmpl, \%hash ) or return;
  342.  
  343.     for my $mod (@$aref) {
  344.         my $obj = $cb->module_tree( $mod ) or next;
  345.  
  346.         if( my $readme = $obj->readme ) {
  347.  
  348.             $self->_pager_open;
  349.             print $readme;
  350.             $self->_pager_close;
  351.         }
  352.     }
  353.  
  354.     return 1;
  355. }
  356.  
  357. sub _reload {
  358.     my $self    = shift;
  359.     my $cb      = $self->backend;
  360.     my $conf    = $cb->configure_object;
  361.     my %hash    = @_;
  362.  
  363.     my($input, $cmd);
  364.     my $tmpl = {
  365.         input   => { default => 'all', store => \$input },
  366.         command => { required => 1, store => \$cmd },
  367.  
  368.     };
  369.  
  370.     check( $tmpl, \%hash ) or return;
  371.  
  372.     if ( $input =~ /cpan/i ) {
  373.         print qq[You want to reload the CPAN code\n];
  374.         print qq[Just type 'q' and then restart... ] .
  375.               qq[Trust me, it is MUCH safer\n];
  376.  
  377.     } elsif ( $input =~ /index/i ) {
  378.         $cb->reload_indices(update_source => 1);
  379.  
  380.     } else {
  381.         print qq[cpan     re-evals the CPANPLUS.pm file\n];
  382.         print qq[index    re-reads the index files\n];
  383.     }
  384.  
  385.     return 1;
  386. }
  387.  
  388. sub _autobundle {
  389.     my $self    = shift;
  390.     my $cb      = $self->backend;
  391.  
  392.     print qq[Writing bundle file... This may take a while\n];
  393.  
  394.     my $where = $cb->autobundle();
  395.  
  396.     print $where
  397.         ? qq[\nWrote autobundle to $where\n]
  398.         : qq[\nCould not create autobundle\n];
  399.  
  400.     return 1;
  401. }
  402.  
  403. sub _set_conf {
  404.     my $self = shift;
  405.     my $cb   = $self->backend;
  406.     my $conf = $cb->configure_object;
  407.     my %hash = @_;
  408.  
  409.     my($aref, $input);
  410.     my $tmpl = {
  411.         result  => { store => \$aref, default => [] },
  412.         input   => { default => 'all', store => \$input },
  413.     };
  414.  
  415.     check( $tmpl, \%hash ) or return;
  416.  
  417.     my $type = shift @$aref;
  418.  
  419.     if( $type eq 'debug' ) {
  420.         print   qq[Sorry you cannot set debug options through ] .
  421.                 qq[this shell in CPANPLUS\n];
  422.         return;
  423.  
  424.     } elsif ( $type eq 'conf' ) {
  425.  
  426.         ### from CPAN.pm :o)
  427.         # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
  428.         # should have been called set and 'o debug' maybe 'set debug'
  429.  
  430.         #    commit             Commit changes to disk
  431.         #    defaults           Reload defaults from disk
  432.         #    init               Interactive setting of all options
  433.  
  434.         my $name    = shift @$aref;
  435.         my $value   = "@$aref";
  436.  
  437.         if( $name eq 'init' ) {
  438.             my $setup = CPANPLUS::Configure::Setup->new(
  439.                         conf    => $cb->configure_object,
  440.                         term    => $self->term,
  441.                         backend => $cb,
  442.                     );
  443.             return $setup->init;
  444.  
  445.         } elsif ($name eq 'commit' ) {;
  446.             $cb->configure_object->save;
  447.             print "Your CPAN++ configuration info has been saved!\n\n";
  448.             return;
  449.  
  450.         } elsif ($name eq 'defaults' ) {
  451.             print   qq[Sorry, CPANPLUS cannot restore default for you.\n] .
  452.                     qq[Perhaps you should run the interactive setup again.\n] .
  453.                     qq[\ttry running 'o conf init'\n];
  454.             return;
  455.  
  456.         ### we're just supplying things in the 'conf' section now,
  457.         ### not the program section.. it's a bit of a hassle to make that
  458.         ### work cleanly with the original CPAN.pm interface, so we'll fix
  459.         ### it when people start complaining, which is hopefully never.
  460.         } else {
  461.             unless( $name ) {
  462.                 my @list =  grep { $_ ne 'hosts' }
  463.                             $conf->options( type => $type );
  464.  
  465.                 my $method = 'get_' . $type;
  466.  
  467.                 local $Data::Dumper::Indent = 0;
  468.                 for my $name ( @list ) {
  469.                     my $val = $conf->$method($name);
  470.                     ($val)  = ref($val)
  471.                                 ? (Data::Dumper::Dumper($val) =~ /= (.*);$/)
  472.                                 : "'$val'";
  473.                     printf  "    %-25s %s\n", $name, $val;
  474.                 }
  475.  
  476.             } elsif ( $name eq 'hosts' ) {
  477.                 print   "Setting hosts is not trivial.\n" .
  478.                         "It is suggested you edit the " .
  479.                         "configuration file manually";
  480.  
  481.             } else {
  482.                 my $method = 'set_' . $type;
  483.                 if( $conf->$method($name => defined $value ? $value : '') ) {
  484.                     my $set_to = defined $value ? $value : 'EMPTY STRING';
  485.                     print "Key '$name' was set to '$set_to'\n";
  486.                 }
  487.             }
  488.         }
  489.     } else {
  490.         print   qq[Known options:\n] .
  491.                 qq[  conf    set or get configuration variables\n] .
  492.                 qq[  debug   set or get debugging options\n];
  493.     }
  494.  
  495.     return;
  496. }
  497.  
  498. ########################
  499. ### search functions ###
  500. ########################
  501.  
  502. sub _author {
  503.     my $self = shift;
  504.     my $cb   = $self->backend;
  505.     my %hash = @_;
  506.  
  507.     my($aref, $short, $input, $class);
  508.     my $tmpl = {
  509.         result  => { store => \$aref, default => ['/./'] },
  510.         short   => { default => 0, store => \$short },
  511.         input   => { default => 'all', store => \$input },
  512.         class   => { default => 'Author', no_override => 1,
  513.                     store => \$class },
  514.     };
  515.  
  516.     check( $tmpl, \%hash ) or return;
  517.  
  518.     my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref;
  519.  
  520.  
  521.     my @rv;
  522.     for my $type (qw[author cpanid]) {
  523.         push @rv, $cb->search( type => $type, allow => \@regexes );
  524.     }
  525.  
  526.     unless( @rv ) {
  527.         print "No object of type $class found for argument $input\n"
  528.             unless $short;
  529.         return;
  530.     }
  531.  
  532.     return $self->_pp_author(
  533.                 result  => \@rv,
  534.                 class   => $class,
  535.                 short   => $short,
  536.                 input   => $input );
  537.  
  538. }
  539.  
  540. ### find all modules matching a query ###
  541. sub _module {
  542.     my $self = shift;
  543.     my $cb   = $self->backend;
  544.     my %hash = @_;
  545.  
  546.     my($aref, $short, $input, $class);
  547.     my $tmpl = {
  548.         result  => { store => \$aref, default => ['/./'] },
  549.         short   => { default => 0, store => \$short },
  550.         input   => { default => 'all', store => \$input },
  551.         class   => { default => 'Module', no_override => 1,
  552.                     store => \$class },
  553.     };
  554.  
  555.     check( $tmpl, \%hash ) or return;
  556.  
  557.     my @rv;
  558.     for my $module (@$aref) {
  559.         if( $module =~ m|/(.+)/| ) {
  560.             push @rv, $cb->search(  type    => 'module',
  561.                                     allow   => [qr/$1/i] );
  562.         } else {
  563.             my $obj = $cb->module_tree( $module ) or next;
  564.             push @rv, $obj;
  565.         }
  566.     }
  567.  
  568.     return $self->_pp_module(
  569.                 result  => \@rv,
  570.                 class   => $class,
  571.                 short   => $short,
  572.                 input   => $input );
  573. }
  574.  
  575. ### find all bundles matching a query ###
  576. sub _bundle {
  577.     my $self = shift;
  578.     my $cb   = $self->backend;
  579.     my %hash = @_;
  580.  
  581.     my($aref, $short, $input, $class);
  582.     my $tmpl = {
  583.         result  => { store => \$aref, default => ['/./'] },
  584.         short   => { default => 0, store => \$short },
  585.         input   => { default => 'all', store => \$input },
  586.         class   => { default => 'Bundle', no_override => 1,
  587.                     store => \$class },
  588.     };
  589.  
  590.     check( $tmpl, \%hash ) or return;
  591.  
  592.     my @rv;
  593.     for my $bundle (@$aref) {
  594.         if( $bundle =~ m|/(.+)/| ) {
  595.             push @rv, $cb->search(  type    => 'module',
  596.                                     allow   => [qr/Bundle::.*?$1/i] );
  597.         } else {
  598.             my $obj = $cb->module_tree( "Bundle::${bundle}" ) or next;
  599.             push @rv, $obj;
  600.         }
  601.     }
  602.  
  603.     return $self->_pp_module(
  604.                 result  => \@rv,
  605.                 class   => $class,
  606.                 short   => $short,
  607.                 input   => $input );
  608. }
  609.  
  610. sub _distribution {
  611.     my $self = shift;
  612.     my $cb   = $self->backend;
  613.     my %hash = @_;
  614.  
  615.     my($aref, $short, $input, $class);
  616.     my $tmpl = {
  617.         result  => { store => \$aref, default => ['/./'] },
  618.         short   => { default => 0, store => \$short },
  619.         input   => { default => 'all', store => \$input },
  620.         class   => { default => 'Distribution', no_override => 1,
  621.                     store => \$class },
  622.     };
  623.  
  624.     check( $tmpl, \%hash ) or return;
  625.  
  626.     my @rv;
  627.     for my $module (@$aref) {
  628.         ### if it's a regex... ###
  629.         if ( my ($match) = $module =~ m|^/(.+)/$|) {
  630.  
  631.             ### something like /FOO/Bar.tar.gz/ was entered
  632.             if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) {
  633.                 my $seen;
  634.  
  635.                 my @data = $cb->search( type    => 'package',
  636.                                         allow   => [qr/$package/i] );
  637.  
  638.                 my @list = $cb->search( type    => 'path',
  639.                                         allow   => [qr/$path/i],
  640.                                         data    => \@data );
  641.  
  642.                 ### make sure we dont list the same dist twice
  643.                 for my $val ( @list ) {
  644.                     next if $seen->{$val->package}++;
  645.  
  646.                     push @rv, $val;
  647.                 }
  648.  
  649.             ### something like /FOO/ or /Bar.tgz/ was entered
  650.             ### so we look both in the path, as well as in the package name
  651.             } else {
  652.                 my $seen;
  653.                 {   my @list = $cb->search( type    => 'package',
  654.                                             allow   => [qr/$match/i] );
  655.  
  656.                     ### make sure we dont list the same dist twice
  657.                     for my $val ( @list ) {
  658.                         next if $seen->{$val->package}++;
  659.  
  660.                         push @rv, $val;
  661.                     }
  662.                 }
  663.  
  664.                 {   my @list = $cb->search( type    => 'path',
  665.                                             allow   => [qr/$match/i] );
  666.  
  667.                     ### make sure we dont list the same dist twice
  668.                     for my $val ( @list ) {
  669.                         next if $seen->{$val->package}++;
  670.  
  671.                         push @rv, $val;
  672.                     }
  673.  
  674.                 }
  675.             }
  676.  
  677.         } else {
  678.  
  679.             ### user entered a full dist, like: R/RC/RCAPUTO/POE-0.19.tar.gz
  680.             if (my ($path,$package) = $module =~ m|^/?(.+)/(.+)$|) {
  681.                 my @data = $cb->search( type    => 'package',
  682.                                         allow   => [qr/^$package$/] );
  683.                 my @list = $cb->search( type    => 'path',
  684.                                         allow   => [qr/$path$/i],
  685.                                         data    => \@data);
  686.  
  687.                 ### make sure we dont list the same dist twice
  688.                 my $seen;
  689.                 for my $val ( @list ) {
  690.                     next if $seen->{$val->package}++;
  691.  
  692.                     push @rv, $val;
  693.                 }
  694.             }
  695.         }
  696.     }
  697.  
  698.     return $self->_pp_distribution(
  699.                 result  => \@rv,
  700.                 class   => $class,
  701.                 short   => $short,
  702.                 input   => $input );
  703. }
  704.  
  705. sub _find_all {
  706.     my $self = shift;
  707.  
  708.     my @rv;
  709.     for my $method (qw[_author _bundle _module _distribution]) {
  710.         my $aref = $self->$method( @_, short => 1 );
  711.  
  712.         push @rv, @$aref if $aref;
  713.     }
  714.  
  715.     print scalar(@rv). " items found\n"
  716. }
  717.  
  718. sub _uptodate {
  719.     my $self = shift;
  720.     my $cb   = $self->backend;
  721.     my %hash = @_;
  722.  
  723.     my($aref, $short, $input, $class);
  724.     my $tmpl = {
  725.         result  => { store => \$aref, default => ['/./'] },
  726.         short   => { default => 0, store => \$short },
  727.         input   => { default => 'all', store => \$input },
  728.         class   => { default => 'Uptodate', no_override => 1,
  729.                     store => \$class },
  730.     };
  731.  
  732.     check( $tmpl, \%hash ) or return;
  733.  
  734.  
  735.     my @rv;
  736.     if( @$aref) {
  737.         for my $module (@$aref) {
  738.             if( $module =~ m|/(.+)/| ) {
  739.                 my @list = $cb->search( type    => 'module',
  740.                                         allow   => [qr/$1/i] );
  741.  
  742.                 ### only add those that are installed and not core
  743.                 push @rv, grep { not $_->package_is_perl_core }
  744.                           grep { $_->installed_file }
  745.                           @list;
  746.  
  747.             } else {
  748.                 my $obj = $cb->module_tree( $module ) or next;
  749.                 push @rv, $obj;
  750.             }
  751.         }
  752.     } else {
  753.         @rv = @{$cb->_all_installed};
  754.     }
  755.  
  756.     return $self->_pp_uptodate(
  757.             result  => \@rv,
  758.             class   => $class,
  759.             short   => $short,
  760.             input   => $input );
  761. }
  762.  
  763. sub _ls {
  764.     my $self = shift;
  765.     my $cb   = $self->backend;
  766.     my %hash = @_;
  767.  
  768.     my($aref, $short, $input, $class);
  769.     my $tmpl = {
  770.         result  => { store => \$aref, default => [] },
  771.         short   => { default => 0, store => \$short },
  772.         input   => { default => 'all', store => \$input },
  773.         class   => { default => 'Uptodate', no_override => 1,
  774.                     store => \$class },
  775.     };
  776.  
  777.     check( $tmpl, \%hash ) or return;
  778.  
  779.     my @rv;
  780.     for my $name (@$aref) {
  781.         my $auth = $cb->author_tree( uc $name );
  782.  
  783.         unless( $auth ) {
  784.             print qq[ls command rejects argument $name: not an author\n];
  785.             next;
  786.         }
  787.  
  788.         push @rv, $auth->distributions;
  789.     }
  790.  
  791.     return $self->_pp_ls(
  792.             result  => \@rv,
  793.             class   => $class,
  794.             short   => $short,
  795.             input   => $input );
  796. }
  797.  
  798. ############################
  799. ### pretty printing subs ###
  800. ############################
  801.  
  802.  
  803. sub _pp_author {
  804.     my $self = shift;
  805.     my %hash = @_;
  806.  
  807.     my( $aref, $short, $class, $input );
  808.     my $tmpl = {
  809.         result  => { required => 1, default => [], strict_type => 1,
  810.                         store => \$aref },
  811.         short   => { default => 0, store => \$short },
  812.         class   => { required => 1, store => \$class },
  813.         input   => { required => 1, store => \$input },
  814.     };
  815.  
  816.     check( $tmpl, \%hash ) or return;
  817.  
  818.     ### no results
  819.     if( !@$aref ) {
  820.         print "No objects of type $class found for argument $input\n"
  821.             unless $short;
  822.  
  823.     ### one result, long output desired;
  824.     } elsif( @$aref == 1 and !$short ) {
  825.  
  826.         ### should look like this:
  827.         #cpan> a KANE
  828.         #Author id = KANE
  829.         #    EMAIL        boumans@frg.eur.nl
  830.         #    FULLNAME     Jos Boumans
  831.  
  832.         my $obj = shift @$aref;
  833.  
  834.         print "$class id = ",                   $obj->cpanid(), "\n";
  835.         printf "    %-12s %s\n", 'EMAIL',       $obj->email();
  836.         printf "    %-12s %s%s\n", 'FULLNAME',  $obj->author();
  837.  
  838.     } else {
  839.  
  840.         ### should look like this:
  841.         #Author          KANE (Jos Boumans)
  842.         #Author          LBROCARD (Leon Brocard)
  843.         #2 items found
  844.  
  845.         for my $obj ( @$aref ) {
  846.             printf qq[%-15s %s ("%s" (%s))\n],
  847.                 $class, $obj->cpanid, $obj->author, $obj->email;
  848.         }
  849.         print scalar(@$aref)." items found\n" unless $short;
  850.     }
  851.  
  852.     return $aref;
  853. }
  854.  
  855. sub _pp_module {
  856.     my $self = shift;
  857.     my %hash = @_;
  858.  
  859.     my( $aref, $short, $class, $input );
  860.     my $tmpl = {
  861.         result  => { required => 1, default => [], strict_type => 1,
  862.                         store => \$aref },
  863.         short   => { default => 0, store => \$short },
  864.         class   => { required => 1, store => \$class },
  865.         input   => { required => 1, store => \$input },
  866.     };
  867.  
  868.     check( $tmpl, \%hash ) or return;
  869.  
  870.  
  871.     ### no results
  872.     if( !@$aref ) {
  873.         print "No objects of type $class found for argument $input\n"
  874.             unless $short;
  875.  
  876.     ### one result, long output desired;
  877.     } elsif( @$aref == 1 and !$short ) {
  878.  
  879.  
  880.         ### should look like this:
  881.         #Module id = LWP
  882.         #    DESCRIPTION  Libwww-perl
  883.         #    CPAN_USERID  GAAS (Gisle Aas <gisle@ActiveState.com>)
  884.         #    CPAN_VERSION 5.64
  885.         #    CPAN_FILE    G/GA/GAAS/libwww-perl-5.64.tar.gz
  886.         #    DSLI_STATUS  RmpO (released,mailing-list,perl,object-oriented)
  887.         #    MANPAGE      LWP - The World-Wide Web library for Perl
  888.         #    INST_FILE    C:\Perl\site\lib\LWP.pm
  889.         #    INST_VERSION 5.62
  890.  
  891.         my $obj     = shift @$aref;
  892.         my $aut_obj = $obj->author;
  893.         my $format  = "    %-12s %s%s\n";
  894.  
  895.         print "$class id = ",           $obj->module(), "\n";
  896.         printf $format, 'DESCRIPTION',  $obj->description()
  897.             if $obj->description();
  898.  
  899.         printf $format, 'CPAN_USERID',  $aut_obj->cpanid() . " (" .
  900.             $aut_obj->author() . " <" . $aut_obj->email() . ">)";
  901.  
  902.         printf $format, 'CPAN_VERSION', $obj->version();
  903.         printf $format, 'CPAN_FILE',    $obj->path() . '/' . $obj->package();
  904.  
  905.         printf $format, 'DSLI_STATUS',  $self->_pp_dslip($obj->dslip)
  906.             if $obj->dslip() =~ /\w/;
  907.  
  908.         #printf $format, 'MANPAGE',      $obj->foo();
  909.         ### this is for bundles... CPAN.pm downloads them,
  910.         #printf $format, 'CONATAINS,
  911.         # parses and goes from there...
  912.  
  913.         printf $format, 'INST_FILE',    $obj->installed_file ||
  914.             '(not installed)';
  915.         printf $format, 'INST_VERSION', $obj->installed_version;
  916.  
  917.  
  918.  
  919.     } else {
  920.  
  921.         ### should look like this:
  922.         #Module          LWP             (G/GA/GAAS/libwww-perl-5.64.tar.gz)
  923.         #Module          POE             (R/RC/RCAPUTO/POE-0.19.tar.gz)
  924.         #2 items found
  925.  
  926.         for my $obj ( @$aref ) {
  927.             printf "%-15s %-15s (%s)\n", $class, $obj->module(),
  928.                 $obj->path() .'/'. $obj->package();
  929.         }
  930.         print scalar(@$aref). " items found\n" unless $short;
  931.     }
  932.  
  933.     return $aref;
  934. }
  935.  
  936. sub _pp_dslip {
  937.     my $self    = shift;
  938.     my $dslip   = shift or return;
  939.  
  940.     my (%_statusD, %_statusS, %_statusL, %_statusI);
  941.  
  942.     @_statusD{qw(? i c a b R M S)} =
  943.         qw(unknown idea pre-alpha alpha beta released mature standard);
  944.  
  945.     @_statusS{qw(? m d u n)}       =
  946.         qw(unknown mailing-list developer comp.lang.perl.* none);
  947.  
  948.     @_statusL{qw(? p c + o h)}     = qw(unknown perl C C++ other hybrid);
  949.     @_statusI{qw(? f r O h)}       =
  950.         qw(unknown functions references+ties object-oriented hybrid);
  951.  
  952.     my @status = split("", $dslip);
  953.  
  954.     my $results = sprintf( "%s (%s,%s,%s,%s)",
  955.         $dslip,
  956.         $_statusD{$status[0]},
  957.         $_statusS{$status[1]},
  958.         $_statusL{$status[2]},
  959.         $_statusI{$status[3]}
  960.     );
  961.  
  962.     return $results;
  963. }
  964.  
  965. sub _pp_distribution {
  966.     my $self = shift;
  967.     my $cb   = $self->backend;
  968.     my %hash = @_;
  969.  
  970.     my( $aref, $short, $class, $input );
  971.     my $tmpl = {
  972.         result  => { required => 1, default => [], strict_type => 1,
  973.                         store => \$aref },
  974.         short   => { default => 0, store => \$short },
  975.         class   => { required => 1, store => \$class },
  976.         input   => { required => 1, store => \$input },
  977.     };
  978.  
  979.     check( $tmpl, \%hash ) or return;
  980.  
  981.  
  982.     ### no results
  983.     if( !@$aref ) {
  984.         print "No objects of type $class found for argument $input\n"
  985.             unless $short;
  986.  
  987.     ### one result, long output desired;
  988.     } elsif( @$aref == 1 and !$short ) {
  989.  
  990.  
  991.         ### should look like this:
  992.         #Distribution id = S/SA/SABECK/POE-Component-Client-POP3-0.02.tar.gz
  993.         #    CPAN_USERID  SABECK (Scott Beck <scott@gossamer-threads.com>)
  994.         #    CONTAINSMODS POE::Component::Client::POP3
  995.  
  996.         my $obj     = shift @$aref;
  997.         my $aut_obj = $obj->author;
  998.         my $pkg     = $obj->package;
  999.         my $format  = "    %-12s %s\n";
  1000.  
  1001.         my @list    = $cb->search(  type    => 'package',
  1002.                                     allow   => [qr/^$pkg$/] );
  1003.  
  1004.  
  1005.         print "$class id = ", $obj->path(), '/', $obj->package(), "\n";
  1006.         printf $format, 'CPAN_USERID',
  1007.                     $aut_obj->cpanid .' ('. $aut_obj->author .
  1008.                     ' '. $aut_obj->email .')';
  1009.  
  1010.         ### yes i know it's ugly, but it's what cpan.pm does
  1011.         printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list);
  1012.  
  1013.     } else {
  1014.  
  1015.         ### should look like this:
  1016.         #Distribution    LWP             (G/GA/GAAS/libwww-perl-5.64.tar.gz)
  1017.         #Distribution    POE             (R/RC/RCAPUTO/POE-0.19.tar.gz)
  1018.         #2 items found
  1019.  
  1020.         for my $obj ( @$aref ) {
  1021.             printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package();
  1022.         }
  1023.  
  1024.         print scalar(@$aref). " items found\n" unless $short;
  1025.     }
  1026.  
  1027.     return $aref;
  1028. }
  1029.  
  1030. sub _pp_uptodate {
  1031.     my $self = shift;
  1032.     my $cb   = $self->backend;
  1033.     my %hash = @_;
  1034.  
  1035.     my( $aref, $short, $class, $input );
  1036.     my $tmpl = {
  1037.         result  => { required => 1, default => [], strict_type => 1,
  1038.                         store => \$aref },
  1039.         short   => { default => 0, store => \$short },
  1040.         class   => { required => 1, store => \$class },
  1041.         input   => { required => 1, store => \$input },
  1042.     };
  1043.  
  1044.     check( $tmpl, \%hash ) or return;
  1045.  
  1046.     my $format  = "%-25s %9s %9s  %s\n";
  1047.  
  1048.     my @not_uptodate;
  1049.     my $no_version;
  1050.  
  1051.     my %seen;
  1052.     for my $mod (@$aref) {
  1053.         next if $mod->package_is_perl_core;
  1054.         next if $seen{ $mod->package }++;
  1055.  
  1056.  
  1057.         if( $mod->installed_file and not $mod->installed_version ) {
  1058.             $no_version++;
  1059.             next;
  1060.         }
  1061.  
  1062.         push @not_uptodate, $mod unless $mod->is_uptodate;
  1063.     }
  1064.  
  1065.     unless( @not_uptodate ) {
  1066.         my $string = $input
  1067.                         ? "for $input"
  1068.                         : '';
  1069.         print "All modules are up to date $string\n";
  1070.         return;
  1071.  
  1072.     } else {
  1073.         printf $format, (   'Package namespace',
  1074.                             'installed',
  1075.                             'latest',
  1076.                             'in CPAN file'
  1077.                         );
  1078.     }
  1079.  
  1080.     for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) {
  1081.         printf $format, (   $mod->module,
  1082.                             $mod->installed_version,
  1083.                             $mod->version,
  1084.                             $mod->path .'/'. $mod->package,
  1085.                         );
  1086.     }
  1087.  
  1088.     print "$no_version installed modules have no (parsable) version number\n"
  1089.         if $no_version;
  1090.  
  1091.     return \@not_uptodate;
  1092. }
  1093.  
  1094. sub _pp_ls {
  1095.     my $self = shift;
  1096.     my $cb   = $self->backend;
  1097.     my %hash = @_;
  1098.  
  1099.     my( $aref, $short, $class, $input );
  1100.     my $tmpl = {
  1101.         result  => { required => 1, default => [], strict_type => 1,
  1102.                         store => \$aref },
  1103.         short   => { default => 0, store => \$short },
  1104.         class   => { required => 1, store => \$class },
  1105.         input   => { required => 1, store => \$input },
  1106.     };
  1107.  
  1108.     check( $tmpl, \%hash ) or return;
  1109.  
  1110.     ### should look something like this:
  1111.     #6272 2002-05-12 KANE/Acme-Comment-1.00.tar.gz
  1112.     #8171 2002-08-13 KANE/Acme-Comment-1.01.zip
  1113.     #7110 2002-09-04 KANE/Acme-Comment-1.02.tar.gz
  1114.     #7571 2002-09-08 KANE/Acme-Intraweb-1.01.tar.gz
  1115.     #6625 2001-08-23 KANE/Acme-POE-Knee-1.10.zip
  1116.     #3058 2003-10-05 KANE/Acme-Test-0.02.tar.gz
  1117.  
  1118.     ### don't know size or mtime
  1119.     #my $format = "%8d %10s %s/%s\n";
  1120.  
  1121.     for my $mod ( sort { $a->package cmp $b->package } @$aref ) {
  1122.         print "\t" . $mod->package . "\n";
  1123.     }
  1124.  
  1125.     return $aref;
  1126. }
  1127.  
  1128.  
  1129. #############################
  1130. ### end pretty print subs ###
  1131. #############################
  1132.  
  1133.  
  1134. sub _bang {
  1135.     my $self = shift;
  1136.     my %hash = @_;
  1137.  
  1138.     my( $input );
  1139.     my $tmpl = {
  1140.         input   => { required => 1, store => \$input },
  1141.     };
  1142.  
  1143.     check( $tmpl, \%hash ) or return;
  1144.  
  1145.     eval $input;
  1146.     warn $@ if $@;
  1147.  
  1148.     print "\n";
  1149.  
  1150.     return;
  1151. }
  1152.  
  1153. sub _help {
  1154.     print qq[
  1155. Display Information
  1156.  a                                    authors
  1157.  b         string           display   bundles
  1158.  d         or               info      distributions
  1159.  m         /regex/          about     modules
  1160.  i         or                         anything of above
  1161.  r         none             reinstall recommendations
  1162.  u                          uninstalled distributions
  1163.  
  1164. Download, Test, Make, Install...
  1165.  get                        download
  1166.  make                       make (implies get)
  1167.  test      modules,         make test (implies make)
  1168.  install   dists, bundles   make install (implies test)
  1169.  clean                      make clean
  1170.  look                       open subshell in these dists' directories
  1171.  readme                     display these dists' README files
  1172.  
  1173. Other
  1174.  h,?           display this menu       ! perl-code   eval a perl command
  1175.  o conf [opt]  set and query options   q             quit the cpan shell
  1176.  reload cpan   load CPAN.pm again      reload index  load newer indices
  1177.  autobundle    Snapshot                force cmd     unconditionally do cmd
  1178. ];
  1179.  
  1180. }
  1181.  
  1182.  
  1183.  
  1184. 1;
  1185. __END__
  1186.  
  1187. =pod
  1188.  
  1189. =head1 NAME
  1190.  
  1191. CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS
  1192.  
  1193. =head1 DESCRIPTION
  1194.  
  1195. The Classic shell is designed to provide the feel of the CPAN.pm shell
  1196. using CPANPLUS underneath.
  1197.  
  1198. For detailed documentation, refer to L<CPAN>.
  1199.  
  1200. =head1 BUG REPORTS
  1201.  
  1202. Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
  1203.  
  1204. =head1 AUTHOR
  1205.  
  1206. This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
  1207.  
  1208. =head1 COPYRIGHT
  1209.  
  1210. The CPAN++ interface (of which this module is a part of) is copyright (c) 
  1211. 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
  1212.  
  1213. This library is free software; you may redistribute and/or modify it 
  1214. under the same terms as Perl itself.
  1215.  
  1216. =head1 SEE ALSO
  1217.  
  1218. L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>
  1219.  
  1220. =cut
  1221.  
  1222.  
  1223. =head1 SEE ALSO
  1224.  
  1225. L<CPAN>
  1226.  
  1227. =cut
  1228.  
  1229.  
  1230.  
  1231. # Local variables:
  1232. # c-indentation-style: bsd
  1233. # c-basic-offset: 4
  1234. # indent-tabs-mode: nil
  1235. # End:
  1236. # vim: expandtab shiftwidth=4:
  1237.